perm filename LABELE.SG[DEN,LMM] blob
sn#070817 filedate 1973-11-01 generic text, type T, neo UTF8
(FILECREATED " 1-NOV-73 19:25:34" S-LABELER)
(LISPXPRINT (QUOTE LABELERVARS)
T)
[RPAQQ LABELERVARS
((* The labeller in all of it's glory (shudder))
(FNS CHECKL COMB COMBCHECK CHECK LLABEL LABELM LABEL1 LABEL1L
COMB1 SIZE COMBINE CLASSES CLASSES2 CLASSIFY3
CLASSIFYNODES CLASSIFYEDGES NODEMARK EDGEMARK LABEL1C
MAKEMULT MAKENODES MAKEEDGES LABELMULT LABEL0A LABELN
LABELE UNCLASS LUNCLASS LLUNCLASS LABELEDGES LABELFV
LLABELNODES MAKEUNCLASSED)
(RECORDS CHECKPERM NPL CHECKVAL LABELING NODETYPE MULTTYPE
EDGETYPE COMBINATION UNCLASSED OTHERTYPE)
(P (I.S.TYPE (QUOTE COMBINATION)
(QUOTE (SETQ $$VAL (COMBINE $$VAL *]
(* The labeller in all of it's glory (shudder))
(DEFINEQ
(CHECKL
[LAMBDA (S SB NPL)
(COND
[(SETQ NPL (CHECK S SB NPL 0))
(COND
((FETCH REMPERMS OF (FETCH NPLLEFT OF NPL))
(HELP "CHECKL ERROR" (LIST S SB NPL)))
(T (LIST (CREATE LABELING LABELED← S UNLABELED← SB LSTRUC←(
REVERSE (FETCH OKPERMS OF
(FETCH NPLLEFT OF NPL]
(T NIL])
(COMB
[LAMBDA (OBJ S SB NPL LABELS)
(COND
((ZEROP LABELS)
(CHECKL S (APPEND SB OBJ)
NPL))
((EQP LABELS (LENGTH OBJ))
(CHECKL (APPEND OBJ S)
SB NPL))
((IGREATERP LABELS (LENGTH OBJ))
NIL)
(T (APPEND (COMBCHECK (CDR OBJ)
(CONS (CAR OBJ)
S)
SB NPL (SUB1 LABELS))
(COMBCHECK (CDR OBJ)
S
(CONS (CAR OBJ)
SB)
NPL LABELS])
(COMBCHECK
[LAMBDA (OBJ S SB NPL LABELS)
(COND
((SETQ NPL (CHECK S SB NPL LABELS))
(COMB (DIFF OBJ (FETCH LABELEDSOFAR OF NPL))
(FETCH LABELEDSOFAR OF NPL)
SB
(FETCH NPLLEFT OF NPL)
(FETCH LABELSLEFT OF NPL)))
(T NIL])
(CHECK
[LAMBDA (S SB NPL LABELS)
(PROG (NEWNPL OBJ POBJ OK)
(SETQ OK (FETCH OKPERMS OF NPL))
(SETQ NPL (FETCH REMPERMS OF NPL))
L1 [COND
((NULL NPL)
(RETURN (CREATE CHECKVAL LABELEDSOFAR← S LABELSLEFT←
LABELS NPLLEFT←(CREATE NPL REMPERMS←
NEWNPL OKPERMS← OK]
(SETQ OBJ (FETCH OBJ OF (CAR NPL)))
(SETQ POBJ (FETCH POBJ OF (CAR NPL)))
L3 (COND
((NULL OBJ)
(GO L8))
((MEMBER (CAR OBJ)
S)
(GO L4))
((MEMBER (CAR OBJ)
SB)
(GO L5)))
L6 (SETQ NEWNPL (CONS (CREATE CHECKPERM REUSING (CAR NPL)
OBJ← OBJ POBJ←
POBJ)
NEWNPL))
L2 (SETQ NPL (CDR NPL))
(GO L1)
L9 (SETQ NEWNPL NIL)
L8 (SETQ OK (CONS (FETCH ORIGPERM OF (CAR NPL))
OK))
(GO L2)
L4 (COND
((MEMBER (CAR POBJ)
S)
(GO L7))
((MEMBER (CAR POBJ)
SB)
(RETURN NIL))
((MINUSP (SETQ LABELS (SUB1 LABELS)))
(RETURN NIL)))
(SETQ S (CONS (CAR POBJ)
S))
(SETQ NPL (APPEND NEWNPL NPL))
(COND
((NULL (CDR OBJ))
(GO L9)))
[SETQ NEWNPL (LIST (CREATE CHECKPERM REUSING (CAR NPL)
OBJ←(CDR OBJ)
POBJ←(CDR POBJ]
(GO L2)
L7 (SETQ OBJ (CDR OBJ))
(SETQ POBJ (CDR POBJ))
(GO L3)
L5 (COND
((MEMBER (CAR POBJ)
S)
(GO L2))
((MEMBER (CAR POBJ)
SB)
(GO L7)))
(GO L6])
(LLABEL
[LAMBDA (OBJECTS LABELS STRUC)
(COND
((NULL LABELS)
(LIST (CREATE LABELING LSTRUC← STRUC)))
(T (FOR L1 IN (LABELM (CAR OBJECTS)
(CAR LABELS)
STRUC)
FOR L2
IN (LLABEL (CDR OBJECTS)
(CDR LABELS)
(FETCH LSTRUC OF L1))
XLIST
(CREATE LABELING REUSING L2 LABELED←(CONS (FETCH LABELED
OF L1)
@])
(LABELM
[LAMBDA (OBJECTS LABELS STRUC)
[SORT (fetch CTABLE of STRUC)
(FUNCTION (LAMBDA (X Y)
(ILESSP (fetch NODENUM of X)
(fetch NODENUM of Y] (* Sort is destructive)
(COND
((NULL LABELS)
(LIST (create LABELING UNLABELED← OBJECTS LSTRUC← STRUC)))
(T (FOR L1 IN (LABEL1 OBJECTS (CAR LABELS)
STRUC)
FOR L2
IN (LABELM (fetch UNLABELED of L1)
(CDR LABELS)
(fetch LSTRUC of L1))
XLIST
(create LABELING reusing L2 LABELED←(CONS (fetch LABELED
of L1)
@])
(LABEL1
[LAMBDA (OBJECTS LABELS STRUC)
(PROG (SZ SZC)
(COND
((ZEROP LABELS)
(LIST (create LABELING UNLABELED← OBJECTS LSTRUC← STRUC)))
((EQ LABELS (SETQ SZ (SIZE OBJECTS)))
(LIST (create LABELING LABELED← OBJECTS LSTRUC← STRUC)))
((IGREATERP LABELS SZ)
NIL)
([NULL (CDR (SETQ OBJECTS (CLASSES OBJECTS STRUC]
(LABEL1C (CAR OBJECTS)
LABELS STRUC))
(T (LABEL1L OBJECTS LABELS STRUC])
(LABEL1L
[LAMBDA (OBJL LABELS STRUC)
(COND
((NULL OBJL)
(COND
((ZEROP LABELS)
(LIST (CREATE LABELING LSTRUC← STRUC)))
(T NIL)))
((ZEROP LABELS)
(LIST (CREATE LABELING UNLABELED←(PROG (R)
(FOR O IN OBJL
DO (SETQ R
(COMBINE O R)))
(RETURN R))
LSTRUC← STRUC)))
(T (PROG (SZ SZC)
[SETQ SZ (IPLUS (SETQ SZC (SIZE (CAR OBJL)))
(FOR O IN (CDR OBJL)
SUM (SIZE O]
(RETURN (FOR I FROM (MAX 0 (IDIFFERENCE LABELS
(IDIFFERENCE
SZ SZC)))
TO (MIN LABELS SZC) FOR L1
IN (LABEL1C (CAR OBJL)
I STRUC)
FOR L2
IN (LABEL1L (CDR OBJL)
(IDIFFERENCE LABELS I)
(FETCH LSTRUC OF L1))
XLIST
(CREATE LABELING
REUSING L2 LABELED←(COMBINE
(FETCH LABELED OF L1)
@)
UNLABELED←(COMBINE
(FETCH UNLABELED OF L1)
@])
(COMB1
[LAMBDA (OBJ LAB UNL PERMS LABELS)
(COND
((ZEROP LABELS)
(LIST (CREATE LABELING LABELED← LAB UNLABELED← UNL LSTRUC←
PERMS)))
((EQUAL LABELS (LENGTH OBJ))
(LIST (CREATE LABELING LABELED←(APPEND OBJ LAB)
UNLABELED← UNL LSTRUC← PERMS)))
(T (NCONC (COMB1 (CDR OBJ)
(CONS (CAR OBJ)
LAB)
UNL PERMS (SUB1 LABELS))
(COMB1 (CDR OBJ)
LAB
(CONS (CAR OBJ)
UNL)
PERMS LABELS])
(SIZE
[LAMBDA (OBJECTS)
(COND
[(MULTTYPE? OBJECTS)
(ITIMES (FETCH MULT OF OBJECTS)
(SIZE (FETCH UNMULTED OF OBJECTS]
[(COMBINATION? OBJECTS)
(IPLUS (SIZE (FETCH OBJ1 OF OBJECTS))
(SIZE (FETCH OBJ2 OF OBJECTS]
((OR (NODETYPE? OBJECTS)
(EDGETYPE? OBJECTS)
(UNCLASSED? OBJECTS))
(LENGTH (CDR OBJECTS)))
(T (HELP OBJECTS "BAD ARG IN SIZE")
0])
(COMBINE
[LAMBDA (O1 O2)
(COND
((NOT O1)
O2)
((NOT O2)
O1)
(T (CREATE COMBINATION OBJ1← O1 OBJ2← O2])
(CLASSES
[LAMBDA (OBJECTS STRUC)
(COND
((COMBINATION? OBJECTS)
(NCONC (CLASSES (FETCH OBJ1 OF OBJECTS)
STRUC)
(CLASSES (FETCH OBJ2 OF OBJECTS)
STRUC)))
((UNCLASSED? OBJECTS)
(CLASSES2 (FETCH OBJECTS OF OBJECTS)
STRUC))
(T (LIST OBJECTS])
(CLASSES2
[LAMBDA (OBJECTS STRUC)
(PROG NIL
(SETQ OBJECTS (GROUPCOUNT OBJECTS))
(RETURN (FOR O IN (CDR OBJECTS) AS M FROM 2 FOR O2
IN (CLASSIFY3 O STRUC)
XLIST
FIRST (CLASSIFY3 (CAR OBJECTS)
STRUC)
(MAKEMULT M O2])
(CLASSIFY3
[LAMBDA (OBJECTS STRUC)
(PROG (N E OTH)
[FOR X IN OBJECTS DO (COND
((NUMBERP X)
(SETQ N (CONS X N)))
((AND (NUMBERP (CAR X))
(NUMBERP (CDR X)))
(SETQ E (CONS X E)))
(T (SETQ OTH (CONS X OTH]
(RETURN (NCONC (MAPCAR (CLASSIFYNODES (DREVERSE N)
STRUC)
(FUNCTION MAKENODES))
(MAPCAR (CLASSIFYEDGES (DREVERSE E)
STRUC)
(FUNCTION MAKEEDGES))
(AND OTH (LIST (LIST (QUOTE OTHERTYPE)
OTH])
(CLASSIFYNODES
[LAMBDA (NODES SSTRUC) (* SSTRUC is used freely
by NODEMARK)
(CDRLIST (GROUPBY (FUNCTION NODEMARK)
NODES])
(CLASSIFYEDGES
[LAMBDA (EDGES SSTRUC)
(CDRLIST (GROUPBY (FUNCTION EDGEMARK)
EDGES])
(NODEMARK
[LAMBDA (NODE) (* SSTRUC is used
freely)
(SETQ NODE (FINDCTE NODE SSTRUC))
(CONS (NODEVALENCE NODE)
(FETCH MARKERS OF NODE])
(EDGEMARK
[LAMBDA (EDGE)
(ORDPAIR (NODEMARK (FETCH NODE1 OF EDGE))
(NODEMARK (FETCH NODE2 OF EDGE])
(LABEL1C
[LAMBDA (OBJECTS LABELS STRUC)
(COND
((ZEROP LABELS)
(LIST (create LABELING UNLABELED← OBJECTS LSTRUC← STRUC)))
((EQ LABELS (SIZE OBJECTS))
(LIST (create LABELING LABELED← OBJECTS LSTRUC← STRUC)))
((NODETYPE? OBJECTS)
(LABELN (fetch NODENUMS of OBJECTS)
LABELS STRUC))
((EDGETYPE? OBJECTS)
(LABELE (fetch NODEPRS of OBJECTS)
LABELS STRUC))
((MULTTYPE? OBJECTS)
(LABELMULT (fetch MULT of OBJECTS)
(fetch UNMULTED of OBJECTS)
LABELS STRUC))
(T (HELP " attempt to label unusual type of objects "
"in LABEL1C"])
(MAKEMULT
[LAMBDA (M OBJ)
(COND
((ZEROP M)
NIL)
((EQ M 1)
OBJ)
(T (CREATE MULTTYPE MULT← M UNMULTED← OBJ])
(MAKENODES
[LAMBDA (NODES)
(COND
((NOT NODES)
NIL)
(T (CREATE NODETYPE NODENUMS← NODES])
(MAKEEDGES
[LAMBDA (EDGES)
(COND
((NOT EDGES)
NIL)
(T (CREATE EDGETYPE NODEPRS← EDGES])
(LABELMULT
[LAMBDA (MULTS UNMULTED LABELS STRUC)
(FOR P IN (NUMPARTITIONS LABELS (SIZE UNMULTED)
0 MULTS)
AS CLP IS (CLCREATE P) FOR L
IN (LABELM UNMULTED (CDRLIST CLP)
STRUC)
XLIST
(create LABELING
reusing L LABELED←(FOR X IN @ AS PR IN CLP
COMBINATION (MAKEMULT (CAR PR)
X))
UNLABELED←(FOR X IN (fetch LABELED of L)
AS PR
IN CLP
COMBINATION
(MAKEMULT (IDIFFERENCE MULTS
(CAR PR))
X])
(LABEL0A
[LAMBDA (OBJECTS STRUC NPL LABELS MAKEFN)
(FOR L
IN (COND
((NOT (FETCH REMPERMS OF NPL))
(COMB1 OBJECTS NIL NIL (FETCH OKPERMS OF NPL)
LABELS))
(T (COMB OBJECTS NIL
(DIFF (FETCH OBJ OF (CAR (FETCH REMPERMS OF NPL)))
OBJECTS)
NPL LABELS)))
XLIST
(CREATE LABELING REUSING L LABELED←(APPLY* MAKEFN @)
UNLABELED←(APPLY*
MAKEFN
(DIFF OBJECTS
(FETCH LABELED OF L)))
LSTRUC←(CREATE STRUCTURE
REUSING STRUC GROUP←(FETCH
LSTRUC OF L])
(LABELN
[LAMBDA (NODENUMS LABELS STRUC)
(LABEL0A NODENUMS STRUC (FINDGROUPNODES NODENUMS STRUC)
LABELS
(FUNCTION MAKENODES])
(LABELE
[LAMBDA (EDGES LABELS STRUC)
(LABEL0A EDGES STRUC (FINDGROUPEDGES EDGES STRUC)
LABELS
(FUNCTION MAKEEDGES])
(UNCLASS
[LAMBDA (OBJECTS)
(COND
((NOT OBJECTS)
NIL)
((UNCLASSED? OBJECTS)
(FETCH OBJECTS OF OBJECTS))
((NODETYPE? OBJECTS)
(FETCH NODENUMS OF OBJECTS))
((EDGETYPE? OBJECTS)
(FETCH NODEPRS OF OBJECTS))
[(MULTTYPE? OBJECTS)
(FOR M TO (FETCH MULT OF OBJECTS)
APPEND
(UNCLASS (FETCH UNMULTED OF OBJECTS]
[(COMBINATION? OBJECTS)
(APPEND (UNCLASS (FETCH OBJ1 OF OBJECTS))
(UNCLASS (FETCH OBJ2 OF OBJECTS]
(T (HELP "BAD ARG TO UNCLASS" OBJECTS)
NIL])
(LUNCLASS
[LAMBDA (LOBJ)
(MAPCAR LOBJ (FUNCTION UNCLASS])
(LLUNCLASS
[LAMBDA (LLOBJ)
(MAPCAR LLOBJ (FUNCTION LUNCLASS])
(LABELEDGES
[LAMBDA (STRUC LABELS)
(FOR L
IN (LABELM (CREATE UNCLASSED OBJECTS←(FOR
CT IN (FETCH CTABLE OF STRUC) FOR N
IN (FETCH NBRS OF CT)
WHEN
(NOT
(IGREATERP
(FETCH NODENUM OF
CT)
N))
XLIST
(CONS (FETCH NODENUM OF
CT)
N)))
LABELS STRUC)
XLIST
(CREATE LABELING REUSING L LABELED←(LUNCLASS @])
(LABELFV
[LAMBDA (STRUC LABELS)
(FOR L IN (LABELM (create UNCLASSED OBJECTS←(COLLECTFV STRUC))
LABELS STRUC)
XLIST
(create LABELING reusing L LABELED←(LUNCLASS @])
(LLABELNODES
[LAMBDA (STRUC LLABELS)
(FOR L IN (LLABEL (MAPCAR (LISTBYVALENCE STRUC)
(FUNCTION MAKEUNCLASSED))
LLABELS STRUC)
XLIST
(create LABELING reusing L LABELED←(LLUNCLASS @])
(MAKEUNCLASSED
[LAMBDA (X)
(COND
((NOT X)
NIL)
(T (CREATE UNCLASSED OBJECTS← X])
)
(RECORD CHECKPERM (OBJ POBJ . ORIGPERM))
(RECORD NPL (REMPERMS . OKPERMS))
(RECORD CHECKVAL (LABELEDSOFAR LABELSLEFT . NPLLEFT))
(RECORD LABELING (LABELED UNLABELED . LSTRUC))
(TYPERECORD NODETYPE NODENUMS)
(TYPERECORD MULTTYPE (MULT . UNMULTED))
(TYPERECORD EDGETYPE NODEPRS)
(TYPERECORD COMBINATION (OBJ1 . OBJ2))
(TYPERECORD UNCLASSED OBJECTS)
(TYPERECORD OTHERTYPE OTHOBJECTS)
[I.S.TYPE (QUOTE COMBINATION)
(QUOTE (SETQ $$VAL (COMBINE $$VAL *]
STOP